(* Creme Caramel Compiler (Triple C) - Michele Caceffo - 2008 *)
(** This module contains all the informations about types, structures and classes that are used almost anywhere along the code; other specific objects are declared only where needed *)
open Exceptions;;
open Syntaxtree;;
open Print_syntaxtree;; (* LDL: debugging module inclusion *)

(** Labels are numeric to simplify things *)
type label      =   int
(** Register is an index for temporary variables *)
type register   =   int
(** Offsets is how far the variable is from the stack pointer *)
type offset     =   int

(** The return type of subroutines *)
type return = 
        SRet of bType   (** For non-void subroutines *)
      | Void            (** For void subroutines *)

(* LDL: define the typedef_table and the case functions *)
type rec_tree = 
    (* LDL: the last 'ide' would represent the record type identification string *)
    Node of ide * rec_tree list * ide
  | Leaf of ide * bType (* LDL: we will assure later that btype not being a record (else it would be part of the tree)*)

(* LDL: this function has been thought up for debugging purposes mainly *)
let rec string_of_rtree (rtree: rec_tree) = match rtree with
  | Node(Ide(s), rtl, (Ide(id))) -> "\tNode(Ide("^s^"),\n" ^ 
                                    (List.fold_left (fun str elem -> str ^ (string_of_rtree elem)) "" rtl)
			            ^") of id="^ s ^"\n\t"
  | Leaf(Ide(s), bt)             -> let bt_str = print_bType bt in
                                    "\tLeaf(Ide("^s^"),\n\t" ^ bt_str ^ "\t)\t"

let get_subRtree (label: ide) (rtree: rec_tree) =
  let rec find_in_rlist l v = match l with
      [] -> raise Not_found
    | Leaf(vl, _) as tree :: _ when vl = v -> tree
    | Node(vl, _, _) as tree :: _ when vl = v -> tree
    | _ :: xs -> find_in_rlist xs v
  in
  match rtree with
      Node(a, rtl, _) ->
	(
	  try
	    find_in_rlist rtl label
	  with Not_found -> raise (NON_DECLARED_FIELD "The requested field does not exist in the record")
	)
    | Leaf(_) -> let msg = "This happens when we reach the base cases of a record, but some dotted expression is found as an expression." ^
		   "This should never happen since the semantic part should have dealt with the case"
		 in raise (CONFIRM_RULE msg)  
		
let countLeaves rtree =		    
  let rec countLeaves_aux leaves_so_far rtree =
    match rtree with
	Leaf(_,_) -> leaves_so_far + 1
      | Node(_,rtl,_) -> List.fold_left countLeaves_aux leaves_so_far rtl
  in countLeaves_aux 0 rtree

type typedef =
    TableRecord of rec_tree

type typedef_table = ((ide, typedef) Hashtbl.t)
(* LDL: --------------------------------------------------------------------- *)

(** The Semantic type, used for semantic analisys *)
(* LDL: we introduce DPointer as a new Semantic type over another semantic type.
         Note that it would be theoretically possible to assign a DBool value
          to a DPointer. Besides that, it would actually be structurally
          impossible becouse of the design of the AST. This it a bit dirty
          choice but it is also practical and fine with a future implementation
          where also booleans might accomplish this role.
 *)
(* LDL: we introduce DRecord as a new semantic type. This type holds an integer
         that works as an incremental identifier for the records
*)
(* LDL: we introduce DWhatever as a new Semantic type over another semantic type.
        This will be used when a part of the semantic analysis would not be cared
         in a given situation, so that we don't want to have an explicit type.
         It is the case of pointers, when dealt as arithmetical expressions.
         In this cases we are not interested at which value they point to, so
         they point to DWhatever.
         Its use is similar in this case to the ( void * ) in C.
*)
type sType =
        DInt           
      | DFloat
      | DBool           
      | DPointer of sType
      | DRecord of ide
      | DWhatever

(* LDL: draws out a string of a semantic type (used for debugging purposes) *)
let rec string_of_sType st = match st with
    DInt               -> "DInt"
  | DFloat             -> "DFloat"
  | DBool              -> "DBool"
  | DPointer(pt)       -> "DPointer(" ^ string_of_sType pt ^ ")"
  | DRecord(Ide(s))    -> "DRecord(Ide(" ^ s ^ "))"
  | DWhatever          -> "DWhatever"
 
(* LDL: build a new function to get the semantic type out of a record list *)
let rec getSemanticRtype (il: ide list) (rtree: rec_tree) =
  let rec find_my_node (il: ide list) (rtree: rec_tree) = match il with
      [] -> rtree
    | x :: xs -> (find_my_node xs (get_subRtree x rtree))  
  and draw_semantic_type (rtree: rec_tree) = match rtree with
      Leaf(_, Int)    ->  DInt
    | Leaf(_, Float)  ->  DFloat
    | Leaf(_, UsrType(ut))  -> (
                                 match ut with
				     (* LDL: the only one possible for the time being *)
			             UsrRecord(_) -> let msg = "This happens when a leaf of the record tree is of type record itself. " ^
				 		       "It is impossible for this to happen."
				 		     in raise (CONFIRM_RULE msg)  
                               )
    | Node(_, _, i) -> DRecord(i)
  in
  draw_semantic_type (find_my_node il rtree)

(* LDL: returns a flattened list of types that are the actual ones in order onto the stack *)
let getPlainTypeList rtree =
    let draw_semantic_type bt = match bt with
	Int    ->  DInt
      | Float  ->  DFloat
      | UsrType(ut)  -> (
                          match ut with
			      (* LDL: the only one possible for the time being *)
			      UsrRecord(_) -> let msg = "It is not possible for a leaf of the record tree to be of type record her itself. "
				 	      in raise (CONFIRM_RULE msg)  
                        )
    in
    let rec getPlainTypeList_aux list_so_far rtree =
      match rtree with
	  Leaf(_,bt) -> (draw_semantic_type bt) :: list_so_far
	| Node(_,rtl,_) -> List.fold_left getPlainTypeList_aux list_so_far rtl
    in List.rev (getPlainTypeList_aux [] rtree)


(** Instructions for intermediate code *)
(* LDL: We decided to add instructions to the instruction set of intermediate.ml
        like REF, DEREF and CPY2PT
*)
type inst_type =
      (* Value Copy *)
        CPY     (** Assignment *)
      | CPY2PT  (* LDL: Assignment to a pointed variable like in ^px = 5 *)
      | SETNULL (* LDL: Assignment of null to a pointer variable like in px = NULL *)
      | AGET    (** Get from array *)
      | ASET    (** Set into array *)
      (* Arithmetical Operations *)
      | ADD     (** Sum *)
      | SUB     (** Subtraction *)
      | MUL     (** Multiplication *)
      | DIV     (** Quotient *)
      (* Logical Operations *)
      | AND     (** Logical AND *)
      | OR      (** Logical OR *)
      | NOT     (** Logical NOT *)
      (* Comparison *)
      | CEQU    (** Compare if Equals *)
      | CNE     (** Compare if Not Equals *)
      | CG      (** Compare if Greater *)
      | CGE     (** Compare if Greater or Equals *)
      (* LDL: Referencing/Dereferencing *)
      | REF     (* LDL: Reference a variable (only variables) *)
      | DEREF   (* LDL: Deference a variable (chains are possible) *)
      (* Jumps *)
      | JNE     (** Jump if Not Equals *)
      | GOTO    (** Goto *)
      (* Subroutines *)
      | PARAM   (** Parameter for subroutine *)
      | CALL    (** Subroutines Call *)
      | RET     (** Return for subroutines *)
      (* System functions *)
      | NOP     (** No Operation *)
      | HALT    (** End of program *)
      | OUT     (** Write on standard Output *)

(** Type of values *)
(* LDL: add an offset as a possible value for an element of the IC *)
type value =
        I of int
      | F of float
      | O of int
      | ONull (* LDL: null pointer *)

(** Element of intermediate code instruction *)
type element =
        Reg of register * sType         (** Register (or temporary variable) with his index and his type *)
      | Off of offset * sType * bool    (** Offset with his gap value, his type and a bool which indicates 
                                        if is a variable defined on a subroutine or the main *)
      | Label of label                  (** Label for a code point *)
      | Val of value                    (** Numerical value *)
      | Subr of string                  (** Subroutine name *)
      | Null                            (** Null element *)


(* LDL: this function traverses the stack using the structure of the given rtree,
        starting from initial_varoff and referring to the dotidel labels to traverse
        the tree.
        It is returned a triplet composed by:
          - an offset, corresponding to the final value on the stack and
          - the size (number of consecutive cells) of the record
          - a plain list of plain types (no records) corresponding to
             the actual cells onto the stack
*)
let rec traverseRTree rtree dotidel varoff =
  match rtree, dotidel with
      (Leaf(_, bt)), [] -> 
	(
	  match bt, varoff with
	      Int, Off(off, _, b)    -> (Off(off, DInt, b)), 1, [DInt]
            | Float, Off(off, _, b)  -> (Off(off, DFloat, b)), 1, [DFloat]
	    | UsrType(ut), _ -> 
	      (
	        match ut with
		    UsrRecord(_) -> let msg = "It is not possible have a record as a leaf for the record tree. " ^
				      "This point is structurally unreachable."
				    in raise (CONFIRM_RULE msg)
	      )
	    | _ -> let msg = "It is not possible not to have an offset as a variable offset here. " ^
		     "This point is structurally unreachable."
		   in raise (CONFIRM_RULE msg)
	)
    | (Node(_,_,rec_id)), [] -> let new_off_element =
				  (
                                    match varoff with
					Off(off, _, b) -> let record_len = countLeaves rtree
					                  and type_list = getPlainTypeList rtree
							  in
							  (Off(off, (DRecord(rec_id)), b)), record_len, type_list
				      | _ -> let msg = "It is not possible have a record as a leaf for the record tree. " ^
					       "This point is structurally unreachable."
					     in raise (CONFIRM_RULE msg)
				  )
				in new_off_element
    | (Leaf(_,_)), somelist -> let msg = "It is not possible to go further down through the record tree. " ^
				 "This point is structurally unreachable."
			       in raise (CONFIRM_RULE msg)
    | (Node(l,rtl,t)), _ -> 
      (
	match rtl, dotidel with
	  | [], _  -> let msg = "It is not possible to go further down through the record tree. " ^
			"This point is structurally unreachable."
		      in raise (CONFIRM_RULE msg)
	  | Leaf(label, _) as n :: _,      x :: xs when label = x -> traverseRTree n xs varoff
	  | Node(label, rtl, _) as n :: _, x :: xs when label = x -> traverseRTree n xs varoff
	  | some_rtree :: rtls, _ -> let (off, stype, b) =
				       (
					 match varoff with 
					     Off(off, stype, b) -> (off, stype, b)
					   | _ -> let msg = "It is not possible have a record as a leaf for the record tree. " ^
						    "This point is structurally unreachable."
						  in raise (CONFIRM_RULE msg)
				       )
				     in
				     let new_off = off + (countLeaves some_rtree) and dummy_node = Node(l, rtls, t) in 
				     traverseRTree dummy_node dotidel (Off(new_off, stype, b))
      )


(** The instruction code, the first operand, the second operand, the destination element*)
type instruction = inst_type * element * element * element

(** The class contains all the method and objects which differ from one subroutine and the other, 
or the main program *)
class funUtils = object(self)

    (** The intermediate code instruction list *)
    val mutable inl         =   []

    (** The table which bind an instruction number with a Label *)
    val mutable label_table =   (Hashtbl.create 0)

    (** The label counter *)
    val mutable labelC      =   0

    (** The offset counter (which is the next offset for a new variable) *)
    val mutable offcount    =   -1

    (** Add an instruction to the list
        @param i The instruction to be added
    *)
    method addInstr (i: instruction)    =   inl <- inl @ [i]; ()

    (** Get the i-th instruction from the list
        @param i The position number
        @return The instruction at position i
    *)
    method getInstr (i: int)            =   List.nth inl i

    (** Get all the instruction list 
        @return The instruction list
    *)
    method getInl   = inl

    (** Get the instruction counter (how many instructions have been added)
        @return The number of added instructions
    *)
    method getIc    = List.length inl

    (* LDL: I need a function for getting the stack pointer without modify it *)
    (** Return the current offset from the stack pointer without changing its value
        @return The current offset
    *)
    method getOffcount : offset   =   offcount

    (** Return the next offset from the stack pointer 
        @return The next offset
    *)
    method stack : offset   =   offcount <- offcount+1; offcount
    
    (** Increments the label counter
        @return the next label index
    *)
    method incLabel =   labelC <- labelC + 1; labelC

    (** Add a new label to the table
        @param lab The label to add
        @param ip The instruction pointer to bind with the label  
    *)
    method addLabel (lab: element) (ip: int)    =   (Hashtbl.add label_table ip lab)

    (** Create a new label
        @return A new Label
    *)
    method getLabel                             =   (Label(self#incLabel))

    (** Check if an instruction is binded with a label
        @param i The index to check
        @return True if the instruction is binded with a label, false otherwise
    *)
    method hasLabel (i: int)                    =   (Hashtbl.mem label_table i)

    (** Retrive the label binded with an instruction
        @param i The instruction associated with a label
        @return The label binded with the instruction
    *)
    method getInstrLabel (i: int)               =   (Hashtbl.find_all label_table i)
end;;

(** This class is an over-structure for the funUtils class, and has methods for managing global variables, like registers, which are indipendent from the function (main or subroutines) that is processed *)
class intermediateCode = object(self)

    (** The instance of the funUtils class created by default *)
    val mutable il          = new funUtils

    (** The variable which count how many registers have been used *)
    val mutable reg         = 0

    (** A wrapper for the getIc method of the funUtils class 
        @return The instruction counter
    *)
    method getIc                =   il#getIc
    
    (** A wrapper for the getIc method of the funUtils class 
        @return The instruction list
    *)
    method getInstructionList   =   il#getInl
    
    (** Setter method which allows substitution of the funUtils class 
        @param newil The new funUtils instance
    *)
    method setInstructionClass (newil: funUtils)   =   il <- newil
    
    (** Getter method  of the funUtils class 
        @return the funUtils instance
    *)
    method getInstructionClass  = il

    (** Add a new instruction, calling the addInstr
        method of the funUtils class
        @param i The instruction to add
    *)
    method addInstr (i: instruction)    =   il#addInstr i
    
    (** Get the instruction at position i, 
        calling the getInstr method of the funUtils class
        @param i The instruction index to get
        @return The instruction at index i
    *)
    method getInstr (i: int)            =   il#getInstr i

    (* LDL: I need a function for getting the stack pointer without modify it *)
    (** Get the current offset for a variable
        @return The current offset
    *)
    method getCurrentStack : offset   =   il#getOffcount

    (** Get the next offset for a variable
        @return The next available offset
    *)
    method stack            =   il#stack
    
    (** Get the next available register index
        @return The next register index
    *)
    method getReg :register =   reg <- reg+1; reg

    (** Wrapper for the addLabel method
        @param lab The element (a label) to bind with the instruction
        @param ip The number of the instruction where the label is binded
    *)
    method addLabel (lab: element) (ip: int)    =   il#addLabel lab ip

    (** Retrive the label binded with an instruction
        @param i The instruction associated with a label
        @return The label binded with the instruction
    *)
    method getLabel                             =   il#getLabel
    
    (** Check if an instruction is binded with a label
        @param i The index to check
        @return True if the instruction is binded with a label, false otherwise
    *)
    method hasLabel (i: int)                    =   il#hasLabel i

    (** Retrive the label binded with an instruction
        @param i The instruction associated with a label
        @return The label binded with the instruction
    *)
    method getInstrLabel (i: int)               =   il#getInstrLabel i

end;;

(** A dec_table binds an ide (variable name) with 3 elements: 2 integers
    (x and y coordinate) and the element associated with the variable
*)
type dec_table = ((ide,(int * int * element)) Hashtbl.t)

(** A proc_entry can be in Building phase (which has the parameter 
    types of the call and the return type) or a Subroutines (which 
    contains all the informations for that function/procedure, such 
    as the local variables declaration and the funUtils class for that
    subroutine)
*)
type proc_entry = 
        Building of return * dec list
      | Subroutine of return * dec list * dec_table * funUtils

(** The proc_table binds the name of a subroutine with its proc_entry *)
type proc_table = ((ide, proc_entry) Hashtbl.t)



(* LDL: it returns the record tree corresponding to the given record *)
let getRTreeFromRecord (Record(idelist): record) (table: dec_table) (tdtable: typedef_table) = 
  let (Ide(id) as var) = (List.hd idelist) in 
  let dec_entry = try (Hashtbl.find table var)
                  with Not_found -> raise (NON_DECLARED_VARIABLE ("ERROR: Undeclared variable: "^ id))
                 (* LDL: note that we take the first element that table spits, whatever it is,
		    instead of differentiating like we did in getVarDeclaration
		 *)
  in
  let (Ide(id)) as var_type_name =
    (
      match dec_entry with
	(_,_,Off(_,stype,_)) -> 
	  (
	    match stype with
		DRecord(ide) -> ide
	      | _ -> let msg = "We are expecting an record variable when we look for a record user defined variable. " ^ 
		       "Found " ^ (string_of_sType stype) ^ "."
			  in raise (CONFIRM_RULE msg)
	  )
	| _ -> let msg = "We are expecting an Offset element when we look for a record user defined variable"
			  in raise (CONFIRM_RULE msg)
    )
  in
  let TableRecord(rtree) = try (Hashtbl.find tdtable var_type_name)
                           with Not_found -> raise (NON_DECLARED_TYPE ("ERROR: Undeclared type: "^ id ^ "\n"))
  in    
  rtree

(* LDL: build a new function to get the semantic type out of a Record node *)
let getSemanticOfRecord (Record(idelist) as r: record) (table: dec_table) (tdtable: typedef_table) =
  let rtree = getRTreeFromRecord r table tdtable and fields = (List.tl idelist) in
  (getSemanticRtype fields rtree)

(* LDL: build a new function to get the semantic type out of a user defined type *)
let getSemanticUsrType (ut: usrType) (table: dec_table) (tdtable: typedef_table) = match ut with
    UsrRecord(r) -> (getSemanticOfRecord r table tdtable)

(** returns the generic semantic type, if it exists
    @param g The generic Type to print
    @param rtree The record type tree so far, that tells the rrecord subordination within a same record
*)
(* LDL: construct a new function for getting the semantic type of a gType *)
let rec getSemanticGtype (g: gType) (table: dec_table) (tdtable: typedef_table) = match g with
    Basic(b)      ->  (
                       match b with
	                   Int    ->  DInt
			 | Float  ->  DFloat
			 | UsrType(ut) -> (getSemanticUsrType ut table tdtable)
                      )
  | Pointer(g)    ->  DPointer(getSemanticGtype g table tdtable)
  | _   ->  let msg = "This happens when it is tried to get the semantic " ^
			"type from a vector or a matrix. This is structurally " ^
			"impossible to get to this point."
		      in raise (CONFIRM_RULE msg)  
